home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / oasis / oasisegs.lha / egs / tsp.lisp < prev    next >
Lisp/Scheme  |  1992-04-17  |  2KB  |  68 lines
  1. (proclaim '(type (array fixnum 2) *dist*))
  2. (proclaim '(type list             *best*))
  3. (proclaim '(type fixnum           *min*))
  4.  
  5. (proclaim '(function run     (fixnum) fixnum))
  6. (proclaim '(function explore (list list list fixnum) fixnum))
  7. (proclaim '(function expand  (list list list fixnum) fixnum))
  8. (proclaim '(function update  (list fixnum) nil))
  9. (proclaim '(function gen     (fixnum) list))
  10.  
  11. (defvar *dist* nil)
  12. (defvar *best* nil)
  13. (defvar *min*  65536)
  14.  
  15. (defun run (n)
  16.        (declare (type fixnum n))
  17.        (setf *dist* (make-array (cons n (cons n nil))
  18.                     :element-type 'fixnum
  19.                     :initial-element 0))
  20.        (setf *best* nil)
  21.        (setf *min*  65536)
  22.        (explore (cdr (gen n)) '() '(0) 0) )
  23.  
  24. (defun explore (c1 c2 tour sum)
  25.        (declare (type list c1)
  26.                 (type list c2)
  27.                 (type list tour)
  28.                 (type fixnum sum))
  29.        (cond ((<= *min* sum) *min*)
  30.              ((and (null c1) (null c2)) (update tour (+ sum (aref *dist* (car tour) 0))))
  31.              ((expand c1 c2 tour sum) (expand c2 c1 tour sum)) ))
  32.  
  33. (defun expand (cities c2 tour sum)
  34.        (declare (type list cities)
  35.                 (type list c2)
  36.                 (type list tour)
  37.                 (type fixnum sum))
  38.        (if (null cities) *min*
  39.            (let ((x  (car cities))
  40.                  (y  (car tour))
  41.                  (c1 (cdr cities)) )
  42.                 (explore c1 c2 (cons x (cons y (cdr tour))) (+ sum (aref *dist* x y)))
  43.                 (expand c1 (cons x c2) tour sum) )))
  44.  
  45. (defun update (tour sum)
  46.        (declare (type list tour)
  47.                 (type fixnum sum))
  48.        (when (> *min* sum) (setf *best* tour) (setf *min* sum)) )
  49.  
  50. (defun gen (n)
  51.        (declare (type fixnum n))
  52.        (let ((seed 197)
  53.              (b 0)
  54.              (cities nil) )
  55.             (declare (type fixnum seed)
  56.                      (type fixnum b)
  57.                      (type list cities))
  58.             (do ((i 0 (+ i 1)))
  59.                 ((= i n) (reverse cities))
  60.                 (declare (type fixnum i))
  61.                 (do ((j (+ i 1) (+ j 1)))
  62.                     ((= j n) (setf cities (cons i cities)))
  63.                     (declare (type fixnum j))
  64.                     (setf seed (rem (+ (* 4757 seed) 1) 32768))
  65.                     (setf b (+ 1 (rem (truncate (/ seed 16)) 256)))
  66.                     (setf (aref *dist* i j) b)
  67.                     (setf (aref *dist* j i) b) ))))
  68.